home *** CD-ROM | disk | FTP | other *** search
/ Mac-Source 1994 July / Mac-Source_July_1994.iso / Other Langs / Tickle-4.0 (tcl) / tcl / src / tclCmdAH.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-11-08  |  23.6 KB  |  981 lines  |  [TEXT/MPS ]
  1. #ifdef MPW
  2. #    pragma segment TCL_CMD_AH
  3. #endif
  4.  
  5. /* 
  6.  * tclCmdAH.c --
  7.  *
  8.  *    This file contains the top-level command routines for most of
  9.  *    the Tcl built-in commands whose names begin with the letters
  10.  *    A to H.
  11.  *
  12.  * Copyright (c) 1987-1993 The Regents of the University of California.
  13.  * All rights reserved.
  14.  *
  15.  * Permission is hereby granted, without written agreement and without
  16.  * license or royalty fees, to use, copy, modify, and distribute this
  17.  * software and its documentation for any purpose, provided that the
  18.  * above copyright notice and the following two paragraphs appear in
  19.  * all copies of this software.
  20.  * 
  21.  * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
  22.  * DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
  23.  * OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
  24.  * CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  25.  *
  26.  * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
  27.  * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
  28.  * AND FITNESS FOR A PARTICULAR PURPOSE.  THE SOFTWARE PROVIDED HEREUNDER IS
  29.  * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
  30.  * PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
  31.  */
  32.  
  33. #ifndef lint
  34. static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclCmdAH.c,v 1.91 93/08/18 16:07:09 ouster Exp $ SPRITE (Berkeley)";
  35. #endif
  36.  
  37. #include "tclInt.h"
  38.  
  39.  
  40. /*
  41.  *----------------------------------------------------------------------
  42.  *
  43.  * Tcl_BreakCmd --
  44.  *
  45.  *    This procedure is invoked to process the "break" Tcl command.
  46.  *    See the user documentation for details on what it does.
  47.  *
  48.  * Results:
  49.  *    A standard Tcl result.
  50.  *
  51.  * Side effects:
  52.  *    See the user documentation.
  53.  *
  54.  *----------------------------------------------------------------------
  55.  */
  56.  
  57.     /* ARGSUSED */
  58. int
  59. Tcl_BreakCmd(dummy, interp, argc, argv)
  60.     ClientData dummy;            /* Not used. */
  61.     Tcl_Interp *interp;            /* Current interpreter. */
  62.     int argc;                /* Number of arguments. */
  63.     char **argv;            /* Argument strings. */
  64. {
  65.     if (argc != 1) {
  66.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  67.         argv[0], "\"", (char *) NULL);
  68.     return TCL_ERROR;
  69.     }
  70.     return TCL_BREAK;
  71. }
  72.  
  73. /*
  74.  *----------------------------------------------------------------------
  75.  *
  76.  * Tcl_CaseCmd --
  77.  *
  78.  *    This procedure is invoked to process the "case" Tcl command.
  79.  *    See the user documentation for details on what it does.
  80.  *
  81.  * Results:
  82.  *    A standard Tcl result.
  83.  *
  84.  * Side effects:
  85.  *    See the user documentation.
  86.  *
  87.  *----------------------------------------------------------------------
  88.  */
  89.  
  90.     /* ARGSUSED */
  91. int
  92. Tcl_CaseCmd(dummy, interp, argc, argv)
  93.     ClientData dummy;            /* Not used. */
  94.     Tcl_Interp *interp;            /* Current interpreter. */
  95.     int argc;                /* Number of arguments. */
  96.     char **argv;            /* Argument strings. */
  97. {
  98.     int i, result;
  99.     int body;
  100.     char *string;
  101.     int caseArgc, splitArgs;
  102.     char **caseArgv;
  103.  
  104.     if (argc < 3) {
  105.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  106.         argv[0], " string ?in? patList body ... ?default body?\"",
  107.         (char *) NULL);
  108.     return TCL_ERROR;
  109.     }
  110.     string = argv[1];
  111.     body = -1;
  112.     if (strcmp(argv[2], "in") == 0) {
  113.     i = 3;
  114.     } else {
  115.     i = 2;
  116.     }
  117.     caseArgc = argc - i;
  118.     caseArgv = argv + i;
  119.  
  120.     /*
  121.      * If all of the pattern/command pairs are lumped into a single
  122.      * argument, split them out again.
  123.      */
  124.  
  125.     splitArgs = 0;
  126.     if (caseArgc == 1) {
  127.     result = Tcl_SplitList(interp, caseArgv[0], &caseArgc, &caseArgv);
  128.     if (result != TCL_OK) {
  129.         return result;
  130.     }
  131.     splitArgs = 1;
  132.     }
  133.  
  134.     for (i = 0; i < caseArgc; i += 2) {
  135.     int patArgc, j;
  136.     char **patArgv;
  137.     register char *p;
  138.  
  139.     if (i == (caseArgc-1)) {
  140.         interp->result = "extra case pattern with no body";
  141.         result = TCL_ERROR;
  142.         goto cleanup;
  143.     }
  144.  
  145.     /*
  146.      * Check for special case of single pattern (no list) with
  147.      * no backslash sequences.
  148.      */
  149.  
  150.     for (p = caseArgv[i]; *p != 0; p++) {
  151.         if (isspace(UCHAR(*p)) || (*p == '\\')) {
  152.         break;
  153.         }
  154.     }
  155.     if (*p == 0) {
  156.         if ((*caseArgv[i] == 'd')
  157.             && (strcmp(caseArgv[i], "default") == 0)) {
  158.         body = i+1;
  159.         }
  160.         if (Tcl_StringMatch(string, caseArgv[i])) {
  161.         body = i+1;
  162.         goto match;
  163.         }
  164.         continue;
  165.     }
  166.  
  167.     /*
  168.      * Break up pattern lists, then check each of the patterns
  169.      * in the list.
  170.      */
  171.  
  172.     result = Tcl_SplitList(interp, caseArgv[i], &patArgc, &patArgv);
  173.     if (result != TCL_OK) {
  174.         goto cleanup;
  175.     }
  176.     for (j = 0; j < patArgc; j++) {
  177.         if (Tcl_StringMatch(string, patArgv[j])) {
  178.         body = i+1;
  179.         break;
  180.         }
  181.     }
  182.     ckfree((char *) patArgv);
  183.     if (j < patArgc) {
  184.         break;
  185.     }
  186.     }
  187.  
  188.     match:
  189.     if (body != -1) {
  190.     result = Tcl_Eval(interp, caseArgv[body]);
  191.     if (result == TCL_ERROR) {
  192.         char msg[100];
  193.         sprintf(msg, "\n    (\"%.50s\" arm line %d)", caseArgv[body-1],
  194.             interp->errorLine);
  195.         Tcl_AddErrorInfo(interp, msg);
  196.     }
  197.     goto cleanup;
  198.     }
  199.  
  200.     /*
  201.      * Nothing matched:  return nothing.
  202.      */
  203.  
  204.     result = TCL_OK;
  205.  
  206.     cleanup:
  207.     if (splitArgs) {
  208.     ckfree((char *) caseArgv);
  209.     }
  210.     return result;
  211. }
  212.  
  213. /*
  214.  *----------------------------------------------------------------------
  215.  *
  216.  * Tcl_CatchCmd --
  217.  *
  218.  *    This procedure is invoked to process the "catch" Tcl command.
  219.  *    See the user documentation for details on what it does.
  220.  *
  221.  * Results:
  222.  *    A standard Tcl result.
  223.  *
  224.  * Side effects:
  225.  *    See the user documentation.
  226.  *
  227.  *----------------------------------------------------------------------
  228.  */
  229.  
  230.     /* ARGSUSED */
  231. int
  232. Tcl_CatchCmd(dummy, interp, argc, argv)
  233.     ClientData dummy;            /* Not used. */
  234.     Tcl_Interp *interp;            /* Current interpreter. */
  235.     int argc;                /* Number of arguments. */
  236.     char **argv;            /* Argument strings. */
  237. {
  238.     int result;
  239.  
  240.     if ((argc != 2) && (argc != 3)) {
  241.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  242.         argv[0], " command ?varName?\"", (char *) NULL);
  243.     return TCL_ERROR;
  244.     }
  245.     result = Tcl_Eval(interp, argv[1]);
  246.     if (argc == 3) {
  247.     if (Tcl_SetVar(interp, argv[2], interp->result, 0) == NULL) {
  248.         Tcl_SetResult(interp, "couldn't save command result in variable",
  249.             TCL_STATIC);
  250.         return TCL_ERROR;
  251.     }
  252.     }
  253.     Tcl_ResetResult(interp);
  254.     sprintf(interp->result, "%d", result);
  255.     return TCL_OK;
  256. }
  257.  
  258. /*
  259.  *----------------------------------------------------------------------
  260.  *
  261.  * Tcl_ConcatCmd --
  262.  *
  263.  *    This procedure is invoked to process the "concat" Tcl command.
  264.  *    See the user documentation for details on what it does.
  265.  *
  266.  * Results:
  267.  *    A standard Tcl result.
  268.  *
  269.  * Side effects:
  270.  *    See the user documentation.
  271.  *
  272.  *----------------------------------------------------------------------
  273.  */
  274.  
  275.     /* ARGSUSED */
  276. int
  277. Tcl_ConcatCmd(dummy, interp, argc, argv)
  278.     ClientData dummy;            /* Not used. */
  279.     Tcl_Interp *interp;            /* Current interpreter. */
  280.     int argc;                /* Number of arguments. */
  281.     char **argv;            /* Argument strings. */
  282. {
  283.     if (argc == 1) {
  284.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  285.         " arg ?arg ...?\"", (char *) NULL);
  286.     return TCL_ERROR;
  287.     }
  288.  
  289.     interp->result = Tcl_Concat(argc-1, argv+1);
  290.     interp->freeProc = (Tcl_FreeProc *) free;
  291.     return TCL_OK;
  292. }
  293.  
  294. /*
  295.  *----------------------------------------------------------------------
  296.  *
  297.  * Tcl_ContinueCmd --
  298.  *
  299.  *    This procedure is invoked to process the "continue" Tcl command.
  300.  *    See the user documentation for details on what it does.
  301.  *
  302.  * Results:
  303.  *    A standard Tcl result.
  304.  *
  305.  * Side effects:
  306.  *    See the user documentation.
  307.  *
  308.  *----------------------------------------------------------------------
  309.  */
  310.  
  311.     /* ARGSUSED */
  312. int
  313. Tcl_ContinueCmd(dummy, interp, argc, argv)
  314.     ClientData dummy;            /* Not used. */
  315.     Tcl_Interp *interp;            /* Current interpreter. */
  316.     int argc;                /* Number of arguments. */
  317.     char **argv;            /* Argument strings. */
  318. {
  319.     if (argc != 1) {
  320.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  321.         "\"", (char *) NULL);
  322.     return TCL_ERROR;
  323.     }
  324.     return TCL_CONTINUE;
  325. }
  326.  
  327. /*
  328.  *----------------------------------------------------------------------
  329.  *
  330.  * Tcl_ErrorCmd --
  331.  *
  332.  *    This procedure is invoked to process the "error" Tcl command.
  333.  *    See the user documentation for details on what it does.
  334.  *
  335.  * Results:
  336.  *    A standard Tcl result.
  337.  *
  338.  * Side effects:
  339.  *    See the user documentation.
  340.  *
  341.  *----------------------------------------------------------------------
  342.  */
  343.  
  344.     /* ARGSUSED */
  345. int
  346. Tcl_ErrorCmd(dummy, interp, argc, argv)
  347.     ClientData dummy;            /* Not used. */
  348.     Tcl_Interp *interp;            /* Current interpreter. */
  349.     int argc;                /* Number of arguments. */
  350.     char **argv;            /* Argument strings. */
  351. {
  352.     Interp *iPtr = (Interp *) interp;
  353.  
  354.     if ((argc < 2) || (argc > 4)) {
  355.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  356.         " message ?errorInfo? ?errorCode?\"", (char *) NULL);
  357.     return TCL_ERROR;
  358.     }
  359.     if ((argc >= 3) && (argv[2][0] != 0)) {
  360.     Tcl_AddErrorInfo(interp, argv[2]);
  361.     iPtr->flags |= ERR_ALREADY_LOGGED;
  362.     }
  363.     if (argc == 4) {
  364.     Tcl_SetVar2(interp, "errorCode", (char *) NULL, argv[3],
  365.         TCL_GLOBAL_ONLY);
  366.     iPtr->flags |= ERROR_CODE_SET;
  367.     }
  368.     Tcl_SetResult(interp, argv[1], TCL_VOLATILE);
  369.     return TCL_ERROR;
  370. }
  371.  
  372. /*
  373.  *----------------------------------------------------------------------
  374.  *
  375.  * Tcl_EvalCmd --
  376.  *
  377.  *    This procedure is invoked to process the "eval" Tcl command.
  378.  *    See the user documentation for details on what it does.
  379.  *
  380.  * Results:
  381.  *    A standard Tcl result.
  382.  *
  383.  * Side effects:
  384.  *    See the user documentation.
  385.  *
  386.  *----------------------------------------------------------------------
  387.  */
  388.  
  389.     /* ARGSUSED */
  390. int
  391. Tcl_EvalCmd(dummy, interp, argc, argv)
  392.     ClientData dummy;            /* Not used. */
  393.     Tcl_Interp *interp;            /* Current interpreter. */
  394.     int argc;                /* Number of arguments. */
  395.     char **argv;            /* Argument strings. */
  396. {
  397.     int result;
  398.     char *cmd;
  399.  
  400.     if (argc < 2) {
  401.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  402.         " arg ?arg ...?\"", (char *) NULL);
  403.     return TCL_ERROR;
  404.     }
  405.     if (argc == 2) {
  406.     result = Tcl_Eval(interp, argv[1]);
  407.     } else {
  408.     
  409.     /*
  410.      * More than one argument:  concatenate them together with spaces
  411.      * between, then evaluate the result.
  412.      */
  413.     
  414.     cmd = Tcl_Concat(argc-1, argv+1);
  415.     result = Tcl_Eval(interp, cmd);
  416.     ckfree(cmd);
  417.     }
  418.     if (result == TCL_ERROR) {
  419.     char msg[60];
  420.     sprintf(msg, "\n    (\"eval\" body line %d)", interp->errorLine);
  421.     Tcl_AddErrorInfo(interp, msg);
  422.     }
  423.     return result;
  424. }
  425.  
  426. /*
  427.  *----------------------------------------------------------------------
  428.  *
  429.  * Tcl_ExprCmd --
  430.  *
  431.  *    This procedure is invoked to process the "expr" Tcl command.
  432.  *    See the user documentation for details on what it does.
  433.  *
  434.  * Results:
  435.  *    A standard Tcl result.
  436.  *
  437.  * Side effects:
  438.  *    See the user documentation.
  439.  *
  440.  *----------------------------------------------------------------------
  441.  */
  442.  
  443.     /* ARGSUSED */
  444. int
  445. Tcl_ExprCmd(dummy, interp, argc, argv)
  446.     ClientData dummy;            /* Not used. */
  447.     Tcl_Interp *interp;            /* Current interpreter. */
  448.     int argc;                /* Number of arguments. */
  449.     char **argv;            /* Argument strings. */
  450. {
  451.     Tcl_DString buffer;
  452.     int i, result;
  453.  
  454.     if (argc < 2) {
  455.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  456.         " arg ?arg ...?\"", (char *) NULL);
  457.     return TCL_ERROR;
  458.     }
  459.  
  460.     if (argc == 2) {
  461.     return Tcl_ExprString(interp, argv[1]);
  462.     }
  463.     Tcl_DStringInit(&buffer);
  464.     Tcl_DStringAppend(&buffer, argv[1], -1);
  465.     for (i = 2; i < argc; i++) {
  466.     Tcl_DStringAppend(&buffer, " ", 1);
  467.     Tcl_DStringAppend(&buffer, argv[i], -1);
  468.     }
  469.     result = Tcl_ExprString(interp, buffer.string);
  470.     Tcl_DStringFree(&buffer);
  471.     return result;
  472. }
  473.  
  474. /*
  475.  *----------------------------------------------------------------------
  476.  *
  477.  * Tcl_ForCmd --
  478.  *
  479.  *    This procedure is invoked to process the "for" Tcl command.
  480.  *    See the user documentation for details on what it does.
  481.  *
  482.  * Results:
  483.  *    A standard Tcl result.
  484.  *
  485.  * Side effects:
  486.  *    See the user documentation.
  487.  *
  488.  *----------------------------------------------------------------------
  489.  */
  490.  
  491.     /* ARGSUSED */
  492. int
  493. Tcl_ForCmd(dummy, interp, argc, argv)
  494.     ClientData dummy;            /* Not used. */
  495.     Tcl_Interp *interp;            /* Current interpreter. */
  496.     int argc;                /* Number of arguments. */
  497.     char **argv;            /* Argument strings. */
  498. {
  499.     int result, value;
  500.  
  501.     if (argc != 5) {
  502.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  503.         " start test next command\"", (char *) NULL);
  504.     return TCL_ERROR;
  505.     }
  506.  
  507.     result = Tcl_Eval(interp, argv[1]);
  508.     if (result != TCL_OK) {
  509.     if (result == TCL_ERROR) {
  510.         Tcl_AddErrorInfo(interp, "\n    (\"for\" initial command)");
  511.     }
  512.     return result;
  513.     }
  514.     while (1) {
  515. #ifdef NEVER_DEFINED
  516. #ifdef ALLOW_USER_BREAK
  517.         if (Tcl_User_Wants_Break(interp))
  518.             {
  519.             result = TCL_ERROR;
  520.             break;
  521.             }
  522. #endif
  523. #endif
  524.     result = Tcl_ExprBoolean(interp, argv[2], &value);
  525.     if (result != TCL_OK) {
  526.         return result;
  527.     }
  528.     if (!value) {
  529.         break;
  530.     }
  531.     result = Tcl_Eval(interp, argv[4]);
  532.     if (result == TCL_CONTINUE) {
  533.         result = TCL_OK;
  534.     } else if (result != TCL_OK) {
  535.         if (result == TCL_ERROR) {
  536.         char msg[60];
  537.         sprintf(msg, "\n    (\"for\" body line %d)", interp->errorLine);
  538.         Tcl_AddErrorInfo(interp, msg);
  539.         }
  540.         break;
  541.     }
  542.     result = Tcl_Eval(interp, argv[3]);
  543.     if (result == TCL_BREAK) {
  544.         break;
  545.     } else if (result != TCL_OK) {
  546.         if (result == TCL_ERROR) {
  547.         Tcl_AddErrorInfo(interp, "\n    (\"for\" loop-end command)");
  548.         }
  549.         return result;
  550.     }
  551.     }
  552.     if (result == TCL_BREAK) {
  553.     result = TCL_OK;
  554.     }
  555.     if (result == TCL_OK) {
  556.     Tcl_ResetResult(interp);
  557.     }
  558.     return result;
  559. }
  560.  
  561. /*
  562.  *----------------------------------------------------------------------
  563.  *
  564.  * Tcl_ForeachCmd --
  565.  *
  566.  *    This procedure is invoked to process the "foreach" Tcl command.
  567.  *    See the user documentation for details on what it does.
  568.  *
  569.  * Results:
  570.  *    A standard Tcl result.
  571.  *
  572.  * Side effects:
  573.  *    See the user documentation.
  574.  *
  575.  *----------------------------------------------------------------------
  576.  */
  577.  
  578.     /* ARGSUSED */
  579. int
  580. Tcl_ForeachCmd(dummy, interp, argc, argv)
  581.     ClientData dummy;            /* Not used. */
  582.     Tcl_Interp *interp;            /* Current interpreter. */
  583.     int argc;                /* Number of arguments. */
  584.     char **argv;            /* Argument strings. */
  585. {
  586.     int listArgc, i, result;
  587.     char **listArgv;
  588.  
  589.     if (argc != 4) {
  590.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  591.         " varName list command\"", (char *) NULL);
  592.     return TCL_ERROR;
  593.     }
  594.  
  595.     /*
  596.      * Break the list up into elements, and execute the command once
  597.      * for each value of the element.
  598.      */
  599.  
  600.     result = Tcl_SplitList(interp, argv[2], &listArgc, &listArgv);
  601.     if (result != TCL_OK) {
  602.     return result;
  603.     }
  604.     for (i = 0; i < listArgc; i++) {
  605. #ifdef NEVER_DEFINED
  606. #ifdef ALLOW_USER_BREAK
  607.         if (Tcl_User_Wants_Break(interp))
  608.             {
  609.             result = TCL_ERROR;
  610.             break;
  611.             }
  612. #endif
  613. #endif
  614.     if (Tcl_SetVar(interp, argv[1], listArgv[i], 0) == NULL) {
  615.         Tcl_SetResult(interp, "couldn't set loop variable", TCL_STATIC);
  616.         result = TCL_ERROR;
  617.         break;
  618.     }
  619.  
  620.     result = Tcl_Eval(interp, argv[3]);
  621.     if (result != TCL_OK) {
  622.         if (result == TCL_CONTINUE) {
  623.         result = TCL_OK;
  624.         } else if (result == TCL_BREAK) {
  625.         result = TCL_OK;
  626.         break;
  627.         } else if (result == TCL_ERROR) {
  628.         char msg[100];
  629.         sprintf(msg, "\n    (\"foreach\" body line %d)",
  630.             interp->errorLine);
  631.         Tcl_AddErrorInfo(interp, msg);
  632.         break;
  633.         } else {
  634.         break;
  635.         }
  636.     }
  637.     }
  638.     ckfree((char *) listArgv);
  639.     if (result == TCL_OK) {
  640.     Tcl_ResetResult(interp);
  641.     }
  642.     return result;
  643. }
  644.  
  645. /*
  646.  *----------------------------------------------------------------------
  647.  *
  648.  * Tcl_FormatCmd --
  649.  *
  650.  *    This procedure is invoked to process the "format" Tcl command.
  651.  *    See the user documentation for details on what it does.
  652.  *
  653.  * Results:
  654.  *    A standard Tcl result.
  655.  *
  656.  * Side effects:
  657.  *    See the user documentation.
  658.  *
  659.  *----------------------------------------------------------------------
  660.  */
  661.  
  662.     /* ARGSUSED */
  663. int
  664. Tcl_FormatCmd(dummy, interp, argc, argv)
  665.     ClientData dummy;            /* Not used. */
  666.     Tcl_Interp *interp;            /* Current interpreter. */
  667.     int argc;                /* Number of arguments. */
  668.     char **argv;            /* Argument strings. */
  669. {
  670.     register char *format;    /* Used to read characters from the format
  671.                  * string. */
  672.     char newFormat[40];        /* A new format specifier is generated here. */
  673.     int width;            /* Field width from field specifier, or 0 if
  674.                  * no width given. */
  675.     int precision;        /* Field precision from field specifier, or 0
  676.                  * if no precision given. */
  677.     int size;            /* Number of bytes needed for result of
  678.                  * conversion, based on type of conversion
  679.                  * ("e", "s", etc.) and width from above. */
  680.     char *oneWordValue = NULL;    /* Used to hold value to pass to sprintf, if
  681.                  * it's a one-word value. */
  682.     double twoWordValue;    /* Used to hold value to pass to sprintf if
  683.                  * it's a two-word value. */
  684.     int useTwoWords;        /* 0 means use oneWordValue, 1 means use
  685.                  * twoWordValue. */
  686.     char *dst = interp->result;    /* Where result is stored.  Starts off at
  687.                  * interp->resultSpace, but may get dynamically
  688.                  * re-allocated if this isn't enough. */
  689.     int dstSize = 0;        /* Number of non-null characters currently
  690.                  * stored at dst. */
  691.     int dstSpace = TCL_RESULT_SIZE;
  692.                 /* Total amount of storage space available
  693.                  * in dst (not including null terminator. */
  694.     int noPercent;        /* Special case for speed:  indicates there's
  695.                  * no field specifier, just a string to copy. */
  696.     int argIndex;        /* Index of argument to substitute next. */
  697.     int gotXpg = 0;        /* Non-zero means that an XPG3 %n$-style
  698.                  * specifier has been seen. */
  699.     int gotSequential = 0;    /* Non-zero means that a regular sequential
  700.                  * (non-XPG3) conversion specifier has been
  701.                  * seen. */
  702.     int useShort;        /* Value to be printed is short (half word). */
  703.     char *end;            /* Used to locate end of numerical fields. */
  704.  
  705.     /*
  706.      * This procedure is a bit nasty.  The goal is to use sprintf to
  707.      * do most of the dirty work.  There are several problems:
  708.      * 1. this procedure can't trust its arguments.
  709.      * 2. we must be able to provide a large enough result area to hold
  710.      *    whatever's generated.  This is hard to estimate.
  711.      * 2. there's no way to move the arguments from argv to the call
  712.      *    to sprintf in a reasonable way.  This is particularly nasty
  713.      *    because some of the arguments may be two-word values (doubles).
  714.      * So, what happens here is to scan the format string one % group
  715.      * at a time, making many individual calls to sprintf.
  716.      */
  717.  
  718.     if (argc < 2) {
  719.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  720.         " formatString ?arg arg ...?\"", (char *) NULL);
  721.     return TCL_ERROR;
  722.     }
  723.     argIndex = 2;
  724.     for (format = argv[1]; *format != 0; ) {
  725.     register char *newPtr = newFormat;
  726.  
  727.     width = precision = useTwoWords = noPercent = useShort = 0;
  728.  
  729.     /*
  730.      * Get rid of any characters before the next field specifier.
  731.      */
  732.  
  733.     if (*format != '%') {
  734.         register char *p;
  735.  
  736.         oneWordValue = p = format;
  737.         while ((*format != '%') && (*format != 0)) {
  738.         *p = *format;
  739.         p++;
  740.         format++;
  741.         }
  742.         size = p - oneWordValue;
  743.         noPercent = 1;
  744.         goto doField;
  745.     }
  746.  
  747.     if (format[1] == '%') {
  748.         oneWordValue = format;
  749.         size = 1;
  750.         noPercent = 1;
  751.         format += 2;
  752.         goto doField;
  753.     }
  754.  
  755.     /*
  756.      * Parse off a field specifier, compute how many characters
  757.      * will be needed to store the result, and substitute for
  758.      * "*" size specifiers.
  759.      */
  760.  
  761.     *newPtr = '%';
  762.     newPtr++;
  763.     format++;
  764.     if (isdigit(UCHAR(*format))) {
  765.         int tmp;
  766.  
  767.         /*
  768.          * Check for an XPG3-style %n$ specification.  Note: there
  769.          * must not be a mixture of XPG3 specs and non-XPG3 specs
  770.          * in the same format string.
  771.          */
  772.  
  773.         tmp = strtoul(format, &end, 10);
  774.         if (*end != '$') {
  775.         goto notXpg;
  776.         }
  777.         format = end+1;
  778.         gotXpg = 1;
  779.         if (gotSequential) {
  780.         goto mixedXPG;
  781.         }
  782.         argIndex = tmp+1;
  783.         if ((argIndex < 2) || (argIndex >= argc)) {
  784.         goto badIndex;
  785.         }
  786.         goto xpgCheckDone;
  787.     }
  788.  
  789.     notXpg:
  790.     gotSequential = 1;
  791.     if (gotXpg) {
  792.         goto mixedXPG;
  793.     }
  794.  
  795.     xpgCheckDone:
  796.     while ((*format == '-') || (*format == '#') || (*format == '0')
  797.         || (*format == ' ') || (*format == '+')) {
  798.         *newPtr = *format;
  799.         newPtr++;
  800.         format++;
  801.     }
  802.     if (isdigit(UCHAR(*format))) {
  803.         width = strtoul(format, &end, 10);
  804.         format = end;
  805.     } else if (*format == '*') {
  806.         if (argIndex >= argc) {
  807.         goto badIndex;
  808.         }
  809.         if (Tcl_GetInt(interp, argv[argIndex], &width) != TCL_OK) {
  810.         goto fmtError;
  811.         }
  812.         argIndex++;
  813.         format++;
  814.     }
  815.     if (width != 0) {
  816.         sprintf(newPtr, "%d", width);
  817.         while (*newPtr != 0) {
  818.         newPtr++;
  819.         }
  820.     }
  821.     if (*format == '.') {
  822.         *newPtr = '.';
  823.         newPtr++;
  824.         format++;
  825.     }
  826.     if (isdigit(UCHAR(*format))) {
  827.         precision = strtoul(format, &end, 10);
  828.         format = end;
  829.     } else if (*format == '*') {
  830.         if (argIndex >= argc) {
  831.         goto badIndex;
  832.         }
  833.         if (Tcl_GetInt(interp, argv[argIndex], &precision) != TCL_OK) {
  834.         goto fmtError;
  835.         }
  836.         argIndex++;
  837.         format++;
  838.     }
  839.     if (precision != 0) {
  840.         sprintf(newPtr, "%d", precision);
  841.         while (*newPtr != 0) {
  842.         newPtr++;
  843.         }
  844.     }
  845.     if (*format == 'l') {
  846.         format++;
  847.     } else if (*format == 'h') {
  848.         useShort = 1;
  849.         *newPtr = 'h';
  850.         newPtr++;
  851.         format++;
  852.     }
  853.     *newPtr = *format;
  854.     newPtr++;
  855.     *newPtr = 0;
  856.     if (argIndex >= argc) {
  857.         goto badIndex;
  858.     }
  859.     switch (*format) {
  860.         case 'i':
  861.         newPtr[-1] = 'd';
  862.         case 'd':
  863.         case 'o':
  864.         case 'u':
  865.         case 'x':
  866.         case 'X':
  867.         if (Tcl_GetInt(interp, argv[argIndex], (int *) &oneWordValue)
  868.             != TCL_OK) {
  869.             goto fmtError;
  870.         }
  871.         size = 40;
  872.         break;
  873.         case 's':
  874.         oneWordValue = argv[argIndex];
  875.         size = strlen(argv[argIndex]);
  876.         break;
  877.         case 'c':
  878.         if (Tcl_GetInt(interp, argv[argIndex], (int *) &oneWordValue)
  879.             != TCL_OK) {
  880.             goto fmtError;
  881.         }
  882.         size = 1;
  883.         break;
  884.         case 'e':
  885.         case 'E':
  886.         case 'f':
  887.         case 'g':
  888.         case 'G':
  889.         if (Tcl_GetDouble(interp, argv[argIndex], &twoWordValue)
  890.             != TCL_OK) {
  891.             goto fmtError;
  892.         }
  893.         useTwoWords = 1;
  894.         size = 320;
  895.         if (precision > 10) {
  896.             size += precision;
  897.         }
  898.         break;
  899.         case 0:
  900.         interp->result =
  901.             "format string ended in middle of field specifier";
  902.         goto fmtError;
  903.         default:
  904.         sprintf(interp->result, "bad field specifier \"%c\"", *format);
  905.         goto fmtError;
  906.     }
  907.     argIndex++;
  908.     format++;
  909.  
  910.     /*
  911.      * Make sure that there's enough space to hold the formatted
  912.      * result, then format it.
  913.      */
  914.  
  915.     doField:
  916.     if (width > size) {
  917.         size = width;
  918.     }
  919.     if ((dstSize + size) > dstSpace) {
  920.         char *newDst;
  921.         int newSpace;
  922.  
  923.         newSpace = 2*(dstSize + size);
  924.         newDst = (char *) ckalloc((unsigned) newSpace+1);
  925.         if (dstSize != 0) {
  926.         memcpy((VOID *) newDst, (VOID *) dst, dstSize);
  927.         }
  928.         if (dstSpace != TCL_RESULT_SIZE) {
  929.         ckfree(dst);
  930.         }
  931.         dst = newDst;
  932.         dstSpace = newSpace;
  933.     }
  934.     if (noPercent) {
  935.         memcpy((VOID *) (dst+dstSize), (VOID *) oneWordValue, size);
  936.         dstSize += size;
  937.         dst[dstSize] = 0;
  938.     } else {
  939.         if (useTwoWords) {
  940.         sprintf(dst+dstSize, newFormat, twoWordValue);
  941.         } else if (useShort) {
  942.         /*
  943.          * The double cast below is needed for a few machines
  944.          * (e.g. Pyramids as of 1/93) that don't like casts
  945.          * directly from pointers to shorts.
  946.          */
  947.  
  948.         sprintf(dst+dstSize, newFormat, (short) (int) oneWordValue);
  949.         } else {
  950.         sprintf(dst+dstSize, newFormat, (char *) oneWordValue);
  951.         }
  952.         dstSize += strlen(dst+dstSize);
  953.     }
  954.     }
  955.  
  956.     interp->result = dst;
  957.     if (dstSpace != TCL_RESULT_SIZE) {
  958.     interp->freeProc = (Tcl_FreeProc *) free;
  959.     } else {
  960.     interp->freeProc = 0;
  961.     }
  962.     return TCL_OK;
  963.  
  964.     mixedXPG:
  965.     interp->result = "cannot mix \"%\" and \"%n$\" conversion specifiers";
  966.     goto fmtError;
  967.  
  968.     badIndex:
  969.     if (gotXpg) {
  970.     interp->result = "\"%n$\" argument index out of range";
  971.     } else {
  972.     interp->result = "not enough arguments for all format specifiers";
  973.     }
  974.  
  975.     fmtError:
  976.     if (dstSpace != TCL_RESULT_SIZE) {
  977.     ckfree(dst);
  978.     }
  979.     return TCL_ERROR;
  980. }
  981.